home *** CD-ROM | disk | FTP | other *** search
/ CD Actual 44 / PC Actual CD 44.iso / Linux / Cygwin / full.exe / Disk1 / data1.cab / Tools / share / tix4.1 / Primitiv.tcl < prev    next >
Encoding:
Text File  |  1998-12-04  |  10.0 KB  |  426 lines
  1. # Primitiv.tcl --
  2. #
  3. #    This is the primitive widget. It is just a frame with proper
  4. #    inheritance wrapping. All new Tix widgets will be derived from
  5. #    this widget
  6. #
  7. # Copyright (c) 1996, Expert Interface Technologies
  8. #
  9. # See the file "license.terms" for information on usage and redistribution
  10. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  11. #
  12.  
  13.  
  14.  
  15. # No superclass, so the superclass switch is not used
  16. #
  17. #
  18. tixWidgetClass tixPrimitive {
  19.     -virtual true
  20.     -superclass {}
  21.     -classname  TixPrimitive
  22.     -method {
  23.     cget configure subwidget subwidgets
  24.     }
  25.     -flag {
  26.     -background -borderwidth -cursor
  27.     -height -highlightbackground -highlightcolor -highlightthickness
  28.     -options -relief -takefocus -width -bd -bg
  29.     }
  30.     -static {
  31.     -options
  32.     }
  33.     -configspec {
  34.     {-background background Background #d9d9d9} 
  35.     {-borderwidth borderWidth BorderWidth 0} 
  36.     {-cursor cursor Cursor ""} 
  37.     {-height height Height 0}
  38.     {-highlightbackground highlightBackground HighlightBackground #c3c3c3}
  39.     {-highlightcolor highlightColor HighlightColor black}
  40.     {-highlightthickness highlightThickness HighlightThickness 0} 
  41.     {-options options Options ""}
  42.     {-relief relief Relief flat}
  43.     {-takefocus takeFocus TakeFocus 0 tixVerifyBoolean} 
  44.     {-width width Width 0}
  45.     }
  46.     -alias {
  47.     {-bd -borderwidth}
  48.     {-bg -background}
  49.     }
  50. }
  51.  
  52. #----------------------------------------------------------------------
  53. # ClassInitialization:
  54. #----------------------------------------------------------------------
  55.  
  56. # not used
  57. # Implemented in C
  58. #
  59. # Override: never
  60. proc tixPrimitive:Constructor {w args} {
  61.  
  62.     upvar #0 $w data
  63.     upvar #0 $data(className) classRec
  64.  
  65.     # Set up some minimal items in the class record.
  66.     #
  67.     set data(w:root)  $w
  68.     set data(rootCmd) $w:root
  69.  
  70.     # We need to create the root widget in order to parse the options
  71.     # database
  72.     tixCallMethod $w CreateRootWidget
  73.  
  74.     # Parse the default options from the options database
  75.     #
  76.     tixPrimitive:ParseDefaultOptions $w
  77.  
  78.     # Parse the options supplied by the user
  79.     #
  80.     tixPrimitive:ParseUserOptions $w $args
  81.  
  82.     # Rename the widget command so that it can be use to access
  83.     # the methods of this class
  84.  
  85.     tixPrimitive:MkWidgetCmd $w
  86.  
  87.     # Inistalize the Widget Record
  88.     #
  89.     tixCallMethod $w InitWidgetRec
  90.  
  91.     # Construct the compound widget
  92.     #
  93.     tixCallMethod $w ConstructWidget
  94.  
  95.     # Do the bindings
  96.     #
  97.     tixCallMethod $w SetBindings
  98.  
  99.     # Call the configuration methods for all "force call" options
  100.     #
  101.     foreach option $classRec(forceCall) {
  102.     tixInt_ChangeOptions $w $option $data($option)
  103.     }
  104. }
  105.  
  106.  
  107. # Create only the root widget. We need the root widget to query the option
  108. # database.
  109. #
  110. # Override: seldom. (unless you want to use a toplevel as root widget)
  111. # Chain   : never.
  112.  
  113. proc tixPrimitive:CreateRootWidget {w args} {
  114.     upvar #0 $w data
  115.     upvar #0 $data(className) classRec
  116.  
  117.     frame $w -class $data(ClassName)
  118. }
  119.  
  120. proc tixPrimitive:ParseDefaultOptions {w} {
  121.     upvar #0 $w data
  122.     upvar #0 $data(className) classRec
  123.  
  124.     # SET UP THE INSTANCE RECORD ACCORDING TO DEFAULT VALUES IN
  125.     # THE OPTIONS DATABASE
  126.     #
  127.     foreach option $classRec(options) {
  128.     set spec [tixInt_GetOptionSpec $data(className) $option]
  129.  
  130.     if {[lindex $spec 0] == "="} {
  131.         continue
  132.     }
  133.  
  134.     set o_name    [lindex $spec 1]
  135.     set o_class   [lindex $spec 2]
  136.     set o_default [lindex $spec 3]
  137.  
  138.     if {![catch "option get $w $o_name $o_class" db_default]} {
  139.         if {$db_default != ""} {
  140.         set data($option) $db_default
  141.         } else {
  142.         set data($option) $o_default
  143.         }
  144.     } else {
  145.         set data($option) $o_default
  146.     }
  147.     }
  148. }
  149.  
  150. proc tixPrimitive:ParseUserOptions {w arglist} {
  151.     upvar #0 $w data
  152.     upvar #0 $data(className) classRec
  153.  
  154.     # SET UP THE INSTANCE RECORD ACCORDING TO COMMAND ARGUMENTS FROM
  155.     # THE USER OF THE TIX LIBRARY (i.e. Application programmer:)
  156.     #
  157.     tixForEach {option arg} $arglist {
  158.     if {[lsearch $classRec(options) $option] != "-1"} {
  159.         set spec [tixInt_GetOptionSpec $data(className) $option]
  160.  
  161.         if {[lindex $spec 0] != "="} {
  162.         set data($option) $arg
  163.         } else {
  164.         set realOption [lindex $spec 1]
  165.         set data($realOption) $arg
  166.         }
  167.     } else {
  168.         error "unknown option $option. Should be: [tixInt_ListOptions $w]"
  169.     }
  170.     }
  171. }
  172.  
  173. #----------------------------------------------------------------------
  174. # Initialize the widget record
  175. # 
  176. #
  177. # Override: always
  178. # Chain   : always, before
  179. proc tixPrimitive:InitWidgetRec {w} {
  180.     # default: do nothing
  181. }
  182.  
  183. #----------------------------------------------------------------------
  184. # SetBindings
  185. # 
  186. #
  187. # Override: sometimes
  188. # Chain   : sometimes, before
  189. #
  190. bind TixDestroyHandler <Destroy> {
  191.     [tixGetMethod %W [set %W(className)] Destructor] %W
  192. }
  193.  
  194. proc tixPrimitive:SetBindings {w} {
  195.     upvar #0 $w data
  196.  
  197.     if {[winfo toplevel $w] == $w} {
  198.     bindtags $w [concat TixDestroyHandler [bindtags $w]]
  199.     } else {
  200.     bind $data(w:root) <Destroy> \
  201.         "[tixGetMethod $w $data(className) Destructor] $w"
  202.     }
  203. }
  204.  
  205. #----------------------------------------------------------------------
  206. # PrivateMethod: ConstructWidget
  207. # 
  208. # Construct and set up the compound widget
  209. #
  210. # Override: sometimes
  211. # Chain   : sometimes, before
  212. #
  213. proc tixPrimitive:ConstructWidget {w} {
  214.     upvar #0 $w data
  215.  
  216.     $data(rootCmd) config \
  217.     -background  $data(-background) \
  218.     -borderwidth $data(-borderwidth) \
  219.     -cursor      $data(-cursor) \
  220.     -relief      $data(-relief)
  221.  
  222.     if {$data(-width) != 0} {
  223.     $data(rootCmd) config -width $data(-width)
  224.     }
  225.     if {$data(-height) != 0} {
  226.     $data(rootCmd) config -height $data(-height)
  227.     }
  228.  
  229.     set rootname *[string range $w 1 end]
  230.  
  231.     tixForEach {spec value} $data(-options) {
  232.     option add $rootname*$spec $value 100
  233.     }
  234. }
  235.  
  236. #----------------------------------------------------------------------
  237. # PrivateMethod: MkWidgetCmd
  238. # 
  239. # Construct and set up the compound widget
  240. #
  241. # Override: sometimes
  242. # Chain   : sometimes, before
  243. #
  244. proc tixPrimitive:MkWidgetCmd {w} {
  245.     upvar #0 $w data
  246.  
  247.     rename $w $data(rootCmd)
  248.     tixInt_MkInstanceCmd $w
  249. }
  250.  
  251.  
  252. #----------------------------------------------------------------------
  253. # ConfigOptions:
  254. #----------------------------------------------------------------------
  255.  
  256. #----------------------------------------------------------------------
  257. # ConfigMethod: config
  258. #
  259. # Configure one option.
  260. # 
  261. # Override: always
  262. # Chain   : automatic.
  263. #
  264. # Note the hack of [winfo width] in this procedure
  265. #
  266. # The hack is necessary because of the bad interaction between TK's geometry
  267. # manager (the packer) and the frame widget. The packer determines the size
  268. # of the root widget of the ComboBox (a frame widget) according to the
  269. # requirement of the slaves inside the frame widget, NOT the -width
  270. # option of the frame widget.
  271. #
  272. # However, everytime the frame widget is
  273. # configured, it sends a geometry request to the packer according to its
  274. # -width and -height options and the packer will temporarily resize
  275. # the frame widget according to the requested size! The packer then realizes
  276. # something is wrong and revert to the size determined by the slaves. This
  277. # cause a flash on the screen.
  278. #
  279. foreach opt {-height -width -background -borderwidth -cursor
  280.         -highlightbackground -highlightcolor -relief -takefocus -bd -bg} {
  281.  
  282.     set tixPrimOpt($opt) 1
  283. }
  284.  
  285. proc tixPrimitive:config {w option value} {
  286.     global tixPrimOpt
  287.     upvar #0 $w data
  288.  
  289.     if [info exists tixPrimOpt($option)] {
  290.     $data(rootCmd) config $option $value
  291.     }
  292. }
  293.  
  294. #----------------------------------------------------------------------
  295. # PublicMethods:
  296. #----------------------------------------------------------------------
  297.  
  298. #----------------------------------------------------------------------
  299. # This method is used to implement the "subwidgets" widget command.
  300. # Will be re-written in C. It can't be used as a public method because
  301. # of the lame substring comparison routines used in tixClass.c
  302. #
  303. #
  304. proc tixPrimitive:subwidgets {w type args} {
  305.     upvar #0 $w data
  306.  
  307.     case $type {
  308.     -class {
  309.         set name [lindex $args 0]
  310.         set args [lrange $args 1 end]
  311.         # access subwidgets of a particular class
  312.         #
  313.         # note: if $name=="Frame", will *not return the root widget as well
  314.         #
  315.         set sub ""
  316.         foreach des [tixDescendants $w] {
  317.         if {[winfo class $des] == $name} {
  318.             lappend sub $des
  319.         }
  320.         }
  321.  
  322.         # Note: if the there is no subwidget of this class, does not
  323.         # cause any error.
  324.         #
  325.         if {$args == ""} {
  326.         return $sub
  327.         } else {
  328.         foreach des $sub {
  329.             eval $des $args
  330.         }
  331.         return ""
  332.         }
  333.     }
  334.     -group {
  335.         set name [lindex $args 0]
  336.         set args [lrange $args 1 end]
  337.         # access subwidgets of a particular group
  338.         #
  339.         if [info exists data(g:$name)] {
  340.         if {$args == ""} {
  341.             set ret ""
  342.             foreach item $data(g:$name) {
  343.             lappend ret $w.$item
  344.             }
  345.             return $ret
  346.         } else {
  347.             foreach item $data(g:$name) {
  348.             eval $w.$item $args
  349.             }
  350.             return ""
  351.         }
  352.         } else {
  353.         error "no such subwidget group $name"
  354.         }
  355.     }
  356.     -all {
  357.         set sub [tixDescendants $w]
  358.  
  359.         if {$args == ""} {
  360.         return $sub
  361.         } else {
  362.         foreach des $sub {
  363.             eval $des $args
  364.         }
  365.         return ""
  366.         }
  367.     }
  368.     default {
  369.         error "unknown flag $type, should be -all, -class or -group"
  370.     }
  371.     }
  372. }
  373.  
  374. #----------------------------------------------------------------------
  375. # PublicMethod: subwidget
  376. #
  377. # Access a subwidget withe a particular name 
  378. #
  379. # Override: never
  380. # Chain   : never
  381. #
  382. proc tixPrimitive:subwidget {w name args} {
  383.     upvar #0 $w data
  384.  
  385.     if [info exists data(w:$name)] {
  386.     if {$args == ""} {
  387.         return $data(w:$name)
  388.     } else {
  389.         return [eval $data(w:$name) $args]
  390.     }
  391.     } else {
  392.     error "no such subwidget $name"
  393.     }
  394. }
  395.  
  396.  
  397. #----------------------------------------------------------------------
  398. # PrivateMethods:
  399. #----------------------------------------------------------------------
  400.  
  401. # delete the widget record and remove the command
  402. #
  403. proc tixPrimitive:Destructor {w} {
  404.     upvar #0 $w data
  405.  
  406.     if {![info exists data(w:root)]} {
  407.     return
  408.     }
  409.  
  410.     if {[info commands $w] != ""} {
  411.     # remove the command
  412.     #
  413.     rename $w ""
  414.     }
  415.  
  416.     if {[info commands $data(rootCmd)] != ""} {
  417.     # remove the command of the root widget
  418.     #
  419.     rename $data(rootCmd) ""
  420.     }
  421.  
  422.     # delete the widget record
  423.     #
  424.     catch {unset data}
  425. }
  426.